CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/pcfig4th.zip/STRINGS.SCR

Text File | 1985-04-23 | 7KB | 1 lines

The following screens add string operations to FORTH.           String variables are stored with the maximum size of            the string in the first byte, and the current length in the     second byte.                                                    When the name of the string is executed, it leaves the address  of the current length; the max. length is there only if you     wish to use it.                                                 The string stack is based on an article in Byte:                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ( Strings: $VAR, $MOVE )                                        FORTH DEFINITIONS DECIMAL                                       : $VAR        ( comp.: len --  exec.: -- addr ;string variable )     <BUILDS DUP C, 0 C, ALLOT  ( comp. maxlen, current len.=0 )     DOES> 1+ ;            ( leave addr of current length byte )                                                                : MAXCOUNT   ( addr -- addr+1, maxlen; get max. size of string )     1+ DUP 2- C@ ;                                                                                                             : $MOVE                       ( source, dest. -- ;move strings )     >R COUNT                                                        R> MAXCOUNT ROT MIN  ( don't overflow dest. )                   DUP >R OVER 1- C!    ( set new count at dest. )                 R> CMOVE ;                                                 -->                                                                                                                             ( Strings: string stack primitives )                                260 CONSTANT $SPACE   $SPACE ALLOT 0 , ( stack space )      HERE 1- CONSTANT $0 ( base of stack, stack grows down )              $0 VARIABLE $P ( stack pointer )                           : $P!  ( -- ;clear string stack )                                    $0 $P !  0 $0 C! ;                                         : $P@  ( -- [$P] ;get current stack pointer )                        $P @ ;                                                     : $DROP  ( -- ;throw out the top string )                            $P@ DUP $0 = ABORT" ? $stack empty " ( don't underflow )        DUP C@ + 1+ $P ! ;  ( move $P to next string )             : $!   ( addr -- ;store string to $VAR )                             $P@ SWAP $DROP $MOVE ; ( drop first to catch error )       -->                                                                                                                                                                                             ( Strings: stack operations, cont. )                            : $PUSH   ( len -- ;adjust $P to accept string; don't move )         $P@ SWAP - DUP $0 $SPACE - < ABORT" ? string is too big "       $P ! ;                                                     : $@      ( addr -- ;fetch $VAR to stack )                           DUP C@ ( current length ) 1+ DUP                                $PUSH $P@ SWAP CMOVE ;                                     : $DUP    ( -- ;duplicate the top $ )                                $P@ $@ ;                                                   : $OVER   ( -- ;copy second $ to the top )                           $P@ COUNT + DUP $0 < 0= ABORT" ? aren't two $'s " $@ ;     : $?      ( addr -- ;print $VAR )                                    COUNT TYPE ;                                               : $.      ( -- ;print top string and drop it )                       $P@ $DROP $? ;                                             -->                                                             ( Strings: printing operators )                                 : $?R    ( addr width -- ;print $VAR right justified in width )      OVER C@ OVER MIN ( use smaller of len, width )                  DUP >R - SPACES 1+ R> TYPE ;                               : $?C    ( addr width -- ;print $VAR centered in width )             OVER C@ OVER MIN ( use smaller of len, width )                  DUP >R - 2 /MOD  ( # spaces to print )                          DUP SPACES + SWAP 1+ R> TYPE SPACES ;                      : $.R    ( width -- ;print top $ right justified )                   $P@ SWAP $DROP $?R ;                                       : $.C    ( width -- ;print top $ centered )                          $P@ SWAP $DROP $?C ;                                       : ID@    ( NFA -- ;fetch name to $ stack )                           COUNT 31 AND DUP $PUSH DUP $P@ C!  ( make room, set length)     $P@ 1+ SWAP CMOVE                                               $P@ DUP C@ + DUP C@ 127 AND SWAP C! ; ( reset MSB ) -->    ( Strings: comparison operator )                                : $COMPARE  ( -- f ;compare top $'s )                                       ( f=0 if $'s are equal, f>0 if $2>$1, else <0 )          $P@ COUNT 2DUP + COUNT    ( a1+1 n1 a2+1 n2 )                   ROT 2DUP -                ( a1+1 a2+1 n2 n2 n2-n1 )             >R MIN OVER + SWAP                                              DO ( compare over smaller of lengths )                             I C@ OVER C@ -  ( arithmetic comparison )                       -DUP IF RP@ 4 + ! LEAVE THEN  ( result is on R )                1+ ( inc. index into larger string )                         LOOP DROP R> ;                                             -->                                                                                                                                                                                                                                                                                                                             ( Strings: non-destructive $ stack print )                                                                                      : MYSELF LATEST PFA CFA , ; IMMEDIATE                                                                                           : ($?)  DUP $0 < IF DUP COUNT + MYSELF THEN CR $? ;                                                                             : $S?  ( -- ;print contents of $ stack )                             $P@ ($?) CR $0 $P@ -                                            . ." out of " $SPACE . ." bytes used " ;                                                                                   : $"   ( -- ;get string delimited by " from input )                  " PAD $@ ;                                                                                                                 ;S